home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / custom.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  20.3 KB  |  758 lines
  1. ;;; custom.scm: Customization support
  2. ;;;
  3. ;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
  4. ;;;
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Redistribution and use in source and binary forms, with or without
  8. ;;; modification, are permitted provided that the following conditions
  9. ;;; are met:
  10. ;;; 1. Redistributions of source code must retain the above copyright
  11. ;;;    notice, this list of conditions and the following disclaimer.
  12. ;;; 2. Redistributions in binary form must reproduce the above copyright
  13. ;;;    notice, this list of conditions and the following disclaimer in the
  14. ;;;    documentation and/or other materials provided with the distribution.
  15. ;;; 3. Neither the name of authors nor the names of its contributors
  16. ;;;    may be used to endorse or promote products derived from this software
  17. ;;;    without specific prior written permission.
  18. ;;;
  19. ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
  20. ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  21. ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  22. ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
  23. ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  24. ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  25. ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  26. ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  27. ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  28. ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  29. ;;; SUCH DAMAGE.
  30. ;;;;
  31.  
  32. ;; There are complex definitions to experiment the customization
  33. ;; mechanism. Will be simplified once the requirement is cleared up.
  34. ;; -- YamaKen
  35.  
  36. (require "i18n.scm")
  37. (require "util.scm")
  38. (require "key.scm")
  39.  
  40. ;; config
  41. (define key-list->gui-key-list 'key-list-export-as-basic)
  42. (define gui-key-list->key-list 'key-list-import-as-basic)
  43. ;;(define key-list->gui-key-list 'key-list-export-as-traditional)
  44. ;;(define gui-key-list->key-list 'key-list-import-as-traditional)
  45.  
  46. ;; public
  47. (define custom-activity-hooks ())
  48. (define custom-get-hooks ())
  49. (define custom-set-hooks ())
  50. (define custom-literalize-hooks ())
  51. (define custom-update-hooks ())
  52. (define custom-group-update-hooks ())
  53. (define custom-group-list-update-hooks ())
  54.  
  55. ;; private
  56. (define custom-full-featured? #t)
  57. (define custom-rec-alist ())
  58. (define custom-group-rec-alist ())
  59. (define custom-subgroup-alist ())
  60.  
  61. (define custom-validator-alist
  62.   '((boolean      . custom-boolean?)
  63.     (integer      . custom-integer?)
  64.     (string       . custom-string?)
  65.     (pathname     . custom-pathname?)
  66.     (choice       . custom-valid-choice?)
  67.     (ordered-list . custom-ordered-list?)
  68.     (key          . custom-key?)))
  69.  
  70. (define anything?
  71.   (lambda (x)
  72.     #t))
  73.  
  74. (define custom-boolean?
  75.   (lambda (x)
  76.     #t))
  77.  
  78. (define custom-integer?
  79.   (lambda (x min max)
  80.     (and (integer? x)
  81.      (<= min x)
  82.      (<= x max))))
  83.  
  84. (define custom-string?
  85.   (lambda (x regex)
  86.     (string? x)))
  87.  
  88. (define custom-pathname?
  89.   (lambda (str type)
  90.     (and (string? str)
  91.      (symbol? type)
  92.      (memq type '(regular-file directory)))))
  93.  
  94. (define custom-valid-choice?
  95.   (lambda arg
  96.     (let ((sym (car arg))
  97.       (choice-rec-alist (cdr arg)))
  98.       (and (symbol? sym)
  99.        (assq sym choice-rec-alist)
  100.        #t))))
  101.  
  102. (define custom-ordered-list?
  103.   (lambda arg
  104.     (let ((syms (car arg))
  105.       (choice-rec-alist (cdr arg)))
  106.       (and (list? syms)
  107.        (every (lambda (sym)
  108.             (apply custom-valid-choice? (cons sym choice-rec-alist)))
  109.           syms)))))
  110.  
  111. (define custom-key?
  112.   (lambda (key-repls)
  113.     (and (list? key-repls)
  114.      (every (lambda (key)
  115.           (or (and (string? key)  ;; "<Control>a"
  116.                ;;(valid-strict-key-str? key)
  117.                (valid-key-str? key))  ;; acceps translators
  118.               (and (symbol? key)  ;; 'generic-cancel-key
  119.                (custom-exist? key 'key))))
  120.         key-repls))))
  121.  
  122. (define custom-pathname-type
  123.   (lambda (custom-sym)
  124.     (car (custom-type-attrs custom-sym))))
  125.  
  126. (define custom-expand-key-references
  127.   (lambda (key)
  128.     (cond
  129.      ((string? key)
  130.       (list (key-str->gui-key-str key)))
  131.      ((list? key)
  132.       (append-map custom-expand-key-references key))
  133.      ((and (symbol? key)
  134.        (custom-exist? key 'key))
  135.       (custom-expand-key-references (custom-value key)))
  136.      (else
  137.       ()))))
  138.  
  139. ;; TODO
  140. (define custom-key-advanced-editor?
  141.   (lambda (custom-sym)
  142.     #f))
  143.  
  144. (define reversed-tag-prefix-alist
  145.   (map (lambda (pair)
  146.      (cons (cdr pair)
  147.            (car pair)))
  148.        tag-prefix-alist))
  149.  
  150. ;; TODO: write test
  151. ;; (key-str->key-list "<Control><Shift><IgnoreRegularShift>return")
  152. ;;   -> (Control_key Shift_key IgnoreRegularShift "return")
  153. ;; (key-str->key-list "C-M-a")
  154. ;;   -> (Control_key Meta_key "a")
  155. (define key-str->key-list
  156.   (lambda (key-str)
  157.     (unfold (compose not car parse-key-prefix)
  158.         (compose car parse-key-prefix)
  159.         (compose cdr parse-key-prefix)
  160.         key-str
  161.         (compose list cdr parse-key-prefix))))
  162.  
  163. ;; TODO: write test
  164. (define key-list->key-str
  165.   (lambda (key-list)
  166.     (string-append-map
  167.      (lambda (elem)
  168.        (if (symbol? elem)
  169.        (let ((mod (cdr (assq elem reversed-tag-prefix-alist))))
  170.          (string-append "<" mod ">"))
  171.        elem))
  172.      key-list)))
  173.  
  174. ;; TODO: write test
  175. (define map-key-list-body
  176.   (lambda (body-mapper key-list)
  177.     (map (lambda (elem)
  178.        (if (string? elem)
  179.            (body-mapper elem)
  180.            elem))
  181.      key-list)))
  182.  
  183. ;; TODO: write test
  184. (define map-key-list-letter
  185.   (lambda (letter-mapper key-list)
  186.     (let ((letter (string->alphabetic-ichar (find string? key-list))))
  187.       (map-key-list-body (lambda (elem)
  188.                (if letter
  189.                    (charcode->string (letter-mapper letter))
  190.                    elem))
  191.              key-list))))
  192.  
  193. ;; TODO: write test
  194. (define map-key-str
  195.   (lambda (key-list-mapper key-str)
  196.     (if (string? key-str)
  197.     (let ((key-list (key-str->key-list key-str)))
  198.       (key-list->key-str (key-list-mapper key-list)))
  199.     key-str)))
  200.  
  201. ;; TODO: write test
  202. (define key-list-upcase
  203.   (lambda (key-list)
  204.     (map-key-list-letter ichar-upcase key-list)))
  205.  
  206. ;; TODO: write test
  207. (define key-list-downcase
  208.   (lambda (key-list)
  209.     (map-key-list-letter ichar-downcase key-list)))
  210.  
  211. ;; TODO: write test
  212. (define key-list-visualize-space
  213.   (lambda (key-list)
  214.     (map-key-list-body (lambda (elem)
  215.              (if (string=? elem " ")
  216.                  "space"
  217.                  elem))
  218.               key-list)))
  219.  
  220. ;; TODO: write test
  221. (define key-list-characterize-space
  222.   (lambda (key-list)
  223.     (map-key-list-body (lambda (elem)
  224.              (if (string=? elem "space")
  225.                  " "
  226.                  elem))
  227.               key-list)))
  228.  
  229. ;; TODO: write test
  230. (define key-list-encode-shift
  231.   (lambda (key-list)
  232.     (let* ((has-shift? (memq 'Shift_key key-list))
  233.        (str (find string? key-list))
  234.        (printable (string->printable-ichar str))
  235.        (letter (string->alphabetic-ichar str)))
  236.       (filter-map (lambda (elem)
  237.             (cond
  238.              ((and (eq? elem 'Shift_key)
  239.                (ichar-graphic? printable))
  240.               #f)
  241.              ((and (string? elem)
  242.                has-shift?
  243.                letter)
  244.               (charcode->string (ichar-upcase letter)))
  245.              ((and (string? elem)
  246.                has-shift?
  247.                (ichar-graphic? printable))
  248.               str)
  249.              (else
  250.               elem)))
  251.           key-list))))
  252.  
  253. ;; TODO: write test
  254. (define key-list-decode-shift
  255.   (lambda (key-list)
  256.     (let* ((letter (string->alphabetic-ichar (find string? key-list)))
  257.        (upper-case? (and letter
  258.                  (ichar-upper-case? letter)))
  259.        (has-shift? (memq 'Shift_key key-list))
  260.        (stripped (key-list-downcase key-list)))
  261.       (if (and (not has-shift?)
  262.            upper-case?)
  263.       (cons 'Shift_key stripped)
  264.       stripped))))
  265.  
  266. ;; TODO: write test
  267. (define key-list-ignore-regular-shift
  268.   (lambda (key-list)
  269.     (let ((printable (string->printable-ichar (find string? key-list))))
  270.       (if (ichar-graphic? printable)
  271.       (cons 'IgnoreRegularShift key-list)
  272.       key-list))))
  273.  
  274. ;; TODO: write test
  275. (define key-list-ignore-letter-shift
  276.   (lambda (key-list)
  277.     (let ((letter (string->alphabetic-ichar (find string? key-list))))
  278.       (if letter
  279.       (cons 'IgnoreShift key-list)
  280.       key-list))))
  281.  
  282. ;; TODO: write test
  283. (define key-list-ignore-punct-numeric-shift
  284.   (lambda (key-list)
  285.     (let* ((str (find string? key-list))
  286.        (c (string->printable-ichar str)))
  287.       (if (and (ichar-graphic? c)
  288.            (not (ichar-alphabetic? c)))
  289.       (cons 'IgnoreShift key-list)
  290.       key-list))))
  291.  
  292. ;; TODO: write test
  293. (define key-list-ignore-case
  294.   (lambda (key-list)
  295.     (let ((letter (string->alphabetic-ichar (find string? key-list))))
  296.       (if letter
  297.       (cons 'IgnoreCase key-list)
  298.        key-list))))
  299.  
  300. ;; TODO: write test
  301. (define key-list-strip-shift
  302.   (lambda (key-list)
  303.     (delete 'Shift_key key-list eq?)))
  304.  
  305. ;; TODO: write test
  306. (define key-list-strip-regular-shift
  307.   (lambda (key-list)
  308.     (let* ((str (find string? key-list))
  309.        (printable (string->printable-ichar str)))
  310.       (if (ichar-graphic? printable)
  311.       (key-list-strip-shift key-list)
  312.       key-list))))
  313.  
  314. ;; TODO: write test
  315. (define key-list-strip-translators
  316.   (lambda (key-list)
  317.     (remove translator-prefix? key-list)))
  318.  
  319. ;; TODO: write test
  320. (define key-list-export-as-basic (compose key-list-visualize-space
  321.                       key-list-encode-shift
  322.                       key-list-strip-translators))
  323.  
  324. ;; TODO: write test
  325. (define key-list-import-as-basic (compose key-list-characterize-space
  326.                       key-list-ignore-punct-numeric-shift
  327.                       key-list-ignore-case
  328.                       key-list-decode-shift
  329.                       key-list-strip-regular-shift))
  330.  
  331. ;; TODO: write test
  332. (define key-list-export-as-traditional (compose key-list-visualize-space
  333.                         key-list-strip-translators))
  334.  
  335. ;; TODO: write test
  336. (define key-list-import-as-traditional (compose key-list-characterize-space
  337.                         key-list-ignore-regular-shift))
  338.  
  339. ;; TODO: write test
  340. (define key-str->gui-key-str
  341.   (lambda (key-str)
  342.     (map-key-str (symbol-value key-list->gui-key-list)
  343.          key-str)))
  344.  
  345. ;; TODO: write test
  346. (define gui-key-str->key-str
  347.   (lambda (key-str)
  348.     (map-key-str (symbol-value gui-key-list->key-list)
  349.          key-str)))
  350.  
  351. (define custom-choice-label
  352.   (lambda (custom-sym val-sym)
  353.     (let* ((sym-rec-alist (custom-type-attrs custom-sym))
  354.        (srec (assq val-sym sym-rec-alist)))
  355.       (if srec
  356.       (custom-choice-rec-label srec)
  357.       (symbol->string val-sym)))))
  358.  
  359. (define custom-choice-desc
  360.   (lambda (custom-sym val-sym)
  361.     (let* ((sym-rec-alist (custom-type-attrs custom-sym))
  362.        (srec (assq val-sym sym-rec-alist)))
  363.       (if srec
  364.       (custom-choice-rec-desc srec)
  365.       (symbol->string val-sym)))))
  366.  
  367. (define custom-choice-range-reflect-olist-val
  368.   (lambda (dst-sym src-sym indication-alist)
  369.     (custom-set-type-info!
  370.      dst-sym
  371.      (cons (custom-type dst-sym)
  372.        (action-id-list->choice (custom-value src-sym)
  373.                    indication-alist)))))
  374.  
  375. (define-record 'custom-group-rec
  376.   '((sym   #f)
  377.     (label "")
  378.     (desc  "")))
  379.  
  380. (define define-custom-group
  381.   (lambda (gsym label desc)
  382.     (let ((grec (custom-group-rec-new gsym label desc)))
  383.       (if (not (custom-group-rec gsym))
  384.       (begin
  385.         (set! custom-group-rec-alist (cons grec custom-group-rec-alist))
  386.         (custom-call-hook-procs 'global
  387.                     custom-group-list-update-hooks))))))
  388.  
  389. (define custom-group-rec
  390.   (lambda (gsym)
  391.     (assq gsym custom-group-rec-alist)))
  392.  
  393. ;; API
  394. (define custom-group-label
  395.   (lambda (gsym)
  396.     (custom-group-rec-label (custom-group-rec gsym))))
  397.  
  398. ;; API
  399. (define custom-group-desc
  400.   (lambda (gsym)
  401.     (custom-group-rec-desc (custom-group-rec gsym))))
  402.  
  403. ;; API
  404. (define custom-group-subgroups
  405.   (lambda (gsym)
  406.     (let ((groups (filter-map (lambda (pair)
  407.                 (let ((primary-grp (car pair))
  408.                       (subgrp (cdr pair)))
  409.                   (and (eq? gsym primary-grp)
  410.                        subgrp)))
  411.                   custom-subgroup-alist)))
  412.       (reverse groups))))
  413.  
  414. ;; API
  415. (define custom-list-groups
  416.   (lambda ()
  417.     (let ((groups (map custom-group-rec-sym custom-group-rec-alist)))
  418.       (reverse groups))))
  419.  
  420. ;; API
  421. (define custom-list-primary-groups
  422.   (lambda ()
  423.     (let ((groups (filter-map
  424.            (lambda (grec)
  425.              (let ((grp (custom-group-rec-sym grec)))
  426.                (and (assq grp custom-subgroup-alist)
  427.                 grp)))
  428.            custom-group-rec-alist)))
  429.       (reverse groups))))
  430.  
  431. ;; TODO: rewrite test for 'AND' expression
  432. ;; API
  433. ;; #f means 'any group'
  434. (define custom-collect-by-group
  435.   (lambda groups
  436.     (reverse
  437.      (filter-map (lambda (crec)
  438.            (let ((custom-groups (custom-rec-groups crec)))
  439.              (and (or (not (car groups))
  440.                   (every (lambda (group)
  441.                        (memq group custom-groups))
  442.                      groups))
  443.               (custom-rec-sym crec))))
  444.          custom-rec-alist))))
  445.  
  446. ;; API
  447. (define custom-add-hook
  448.   (lambda (custom-sym hook-sym proc)
  449.     (set-symbol-value! hook-sym (cons (cons custom-sym proc)
  450.                       (symbol-value hook-sym)))))
  451.  
  452. ;; #f for custom-sym means 'any entries'
  453. (define custom-remove-hook
  454.   (lambda (custom-sym hook-sym)
  455.     (let ((removed (if custom-sym
  456.                (alist-delete custom-sym (symbol-value hook-sym) eq?)
  457.                ()))
  458.       (removed? (if custom-sym
  459.             (assq custom-sym (symbol-value hook-sym))
  460.             (not (null? (symbol-value hook-sym))))))
  461.       (set-symbol-value! hook-sym removed)
  462.       removed?)))
  463.  
  464. (define custom-hook-procs
  465.   (lambda (sym hook)
  466.     (let* ((filter (lambda (pair)
  467.              (let ((custom (car pair))
  468.                (proc (cdr pair)))
  469.                (and (eq? sym custom)
  470.                 proc))))
  471.        (procs (filter-map filter
  472.                   hook)))
  473.       procs)))
  474.  
  475. (define custom-call-hook-procs
  476.   (lambda (sym hook)
  477.     (let ((procs (custom-hook-procs sym hook)))
  478.       (map (lambda (proc)
  479.          (proc))
  480.        procs))))
  481.  
  482. (define-record 'custom-rec
  483.   '((sym     #f)
  484.     (default #f)
  485.     (groups  ())
  486.     (type    ())
  487.     (label   "")
  488.     (desc    "")))
  489.  
  490. (define custom-rec
  491.   (lambda (sym)
  492.     (assq sym custom-rec-alist)))
  493.  
  494. ;; TODO: rewrite test for overwriting and 'main' subgroup
  495. ;; API
  496. (define define-custom
  497.   (lambda (sym default groups type label desc)
  498.     (let* ((primary-grp (car groups))
  499.        (subgrps (if (null? (cdr groups))
  500.             '(main)
  501.             (cdr groups)))
  502.        (modified-groups (cons primary-grp subgrps))
  503.        (crec (custom-rec-new sym default modified-groups type label desc)))
  504.       ;; See also require-custom for error handling TODO
  505.       (for-each (lambda (gsym)
  506.           (or (custom-group-rec gsym)
  507.               (error (string-append "undefined group '"
  508.                         (symbol->string gsym)
  509.                         "' is referred by "
  510.                         (symbol->string sym)))))
  511.         modified-groups)
  512.       (set! custom-rec-alist (alist-replace crec custom-rec-alist))
  513.       (custom-call-hook-procs primary-grp custom-group-update-hooks)
  514.       (if (not (symbol-bound? sym))
  515.       (let ((quoted-default (if (or (symbol? default)
  516.                     (list? default))
  517.                     (list 'quote default)
  518.                     default)))
  519.         (eval (list 'define sym quoted-default)
  520.           (interaction-environment))
  521.         (custom-set-value! sym default)))  ;; to apply hooks
  522.       (for-each (lambda (subgrp)
  523.           (let ((registered (custom-group-subgroups primary-grp)))
  524.             (if (not (memq subgrp registered))
  525.             (set! custom-subgroup-alist
  526.                   (cons (cons primary-grp subgrp)
  527.                     custom-subgroup-alist)))))
  528.         subgrps))))
  529.  
  530. ;; #f as type means 'any type'
  531. (define custom-exist?
  532.   (lambda (sym type)
  533.     (and (assq sym custom-rec-alist)
  534.      (or (not type)
  535.          (eq? type
  536.           (custom-type sym))))))
  537.  
  538. ;; API
  539. (define custom-valid?
  540.   (lambda (sym val)
  541.     (let* ((type-name (custom-type sym))
  542.        (type-attrs (custom-type-attrs sym))
  543.        (valid? (symbol-value (cdr (assq type-name
  544.                         custom-validator-alist)))))
  545.       (apply valid? (cons val type-attrs)))))
  546.  
  547. ;; API
  548. (define custom-value
  549.   (lambda (sym)
  550.     (custom-call-hook-procs sym custom-get-hooks)
  551.     (let ((val (symbol-value sym)))
  552.       (if (custom-valid? sym val)
  553.       val
  554.       (custom-default-value sym)))))
  555.  
  556. ;; TODO: rewrite test
  557. ;; API
  558. (define custom-set-value!
  559.   (lambda (sym val)
  560.     (and (custom-valid? sym val)
  561.      (let* ((custom-syms (custom-collect-by-group #f))
  562.         (map-activities (lambda ()
  563.                   (map (lambda (pair)
  564.                      ((cdr pair)))
  565.                        custom-activity-hooks)))
  566.         (pre-activities (map-activities)))
  567.        (set-symbol-value! sym val)
  568.        (if (eq? (custom-type sym)
  569.             'key)
  570.            (let ((key-val (custom-modify-key-predicate-names val)))
  571.          (eval (list 'define (symbol-append sym '?)
  572.                  (list 'make-key-predicate (list 'quote key-val)))
  573.                (interaction-environment))))
  574.        (custom-call-hook-procs sym custom-set-hooks)
  575.        (custom-call-hook-procs sym custom-update-hooks)
  576.        (let ((post-activities (map-activities)))
  577.          (for-each (lambda (another-sym pre post)
  578.              (if (and (not (eq? another-sym sym))
  579.                   (not (eq? (not pre)     ;; normalize bool
  580.                         (not post)))) ;; normalize bool
  581.                  (custom-call-hook-procs another-sym
  582.                              custom-update-hooks)))
  583.                (map car custom-activity-hooks)
  584.                pre-activities
  585.                post-activities)
  586.          #t)))))
  587.  
  588. ;; API
  589. (define custom-touch-value!
  590.   (lambda (sym)
  591.     (custom-set-value! sym
  592.                (custom-value sym))))
  593.  
  594. (define custom-active?
  595.   (lambda (sym)
  596.     (let* ((procs (custom-hook-procs sym custom-activity-hooks))
  597.        (activities (map (lambda (proc)
  598.                   (proc))
  599.                 procs))
  600.        (active? (apply proc-and activities)))
  601.       active?)))
  602.  
  603. ;; API
  604. (define custom-default?
  605.   (lambda (sym)
  606.     (equal? (symbol-value sym)
  607.         (custom-default-value sym))))
  608.  
  609. ;; API
  610. (define custom-default-value
  611.   (lambda (sym)
  612.     (custom-rec-default (custom-rec sym))))
  613.  
  614. ;; API
  615. (define custom-groups
  616.   (lambda (sym)
  617.     (custom-rec-groups (custom-rec sym))))
  618.  
  619. ;; API
  620. (define custom-type
  621.   (lambda (sym)
  622.     (car (custom-rec-type (custom-rec sym)))))
  623.  
  624. (define custom-type-attrs
  625.   (lambda (sym)
  626.     (let* ((crec (custom-rec sym))
  627.        (typedef (custom-rec-type crec)))
  628.       (cdr typedef))))
  629.  
  630. ;; TODO: write test
  631. ;; API for temporary solution
  632. (define custom-type-info
  633.   (lambda (sym)
  634.     (custom-rec-type (custom-rec sym))))
  635.  
  636. ;; TODO: write test
  637. ;; API for temporary solution
  638. (define custom-set-type-info!
  639.   (lambda (sym info)
  640.     (custom-rec-set-type! (custom-rec sym)
  641.               info)
  642.     (custom-call-hook-procs sym custom-update-hooks)))
  643.  
  644. ;; API
  645. (define custom-range
  646.   (lambda (sym)
  647.     (let* ((type (custom-type sym))
  648.        (attrs (custom-type-attrs sym)))
  649.       (case type
  650.     ((choice ordered-list)
  651.      (map custom-choice-rec-sym attrs))
  652.     ((integer string)
  653.      attrs)
  654.     (else
  655.      ())))))
  656.  
  657. ;; API
  658. (define custom-label
  659.   (lambda (sym)
  660.     (custom-rec-label (custom-rec sym))))
  661.  
  662. ;; API
  663. (define custom-desc
  664.   (lambda (sym)
  665.     (custom-rec-desc (custom-rec sym))))
  666.  
  667. (define custom-list-as-literal
  668.   (lambda (lst)
  669.     (let ((canonicalized (map (lambda (elem)
  670.                 (cond
  671.                  ((symbol? elem)
  672.                   (symbol->string elem))
  673.                  ((string? elem)
  674.                   (string-escape elem))
  675.                  (else
  676.                   "")))
  677.                   lst)))
  678.       (string-append "'(" (string-join canonicalized " ") ")"))))
  679.  
  680. ;; API
  681. (define custom-value-as-literal
  682.   (lambda (sym)
  683.     (let ((val (custom-value sym))
  684.       (type (custom-type sym)))
  685.       (cond
  686.        ((eq? type 'integer)
  687.     (number->string val))
  688.        ((eq? type 'string)
  689.     (string-escape val))
  690.        ((eq? type 'pathname)
  691.     (string-escape val))
  692.        ((eq? type 'choice)
  693.     (string-append "'" (symbol->string val)))
  694.        ((or (eq? type 'ordered-list)
  695.         (eq? type 'key))
  696.     (custom-list-as-literal val))
  697.        ((or (eq? val #f)
  698.         (eq? type 'boolean))
  699.     (if (eq? val #f)
  700.         "#f"
  701.         "#t"))))))
  702.  
  703. ;; Don't invoke this from a literalize-hook. It will cause infinite loop
  704. (define custom-definition-as-literal
  705.   (lambda (sym)
  706.     (let ((var (symbol->string sym))
  707.       (val (custom-value-as-literal sym))
  708.       (hooked (custom-call-hook-procs sym custom-literalize-hooks)))
  709.       (if (not (null? hooked))
  710.       (string-join hooked "\n")
  711.       (apply string-append
  712.          (append
  713.           (list "(define " var " " val ")")
  714.           (if (eq? (custom-type sym)
  715.                'key)
  716.               (let ((key-val (custom-list-as-literal
  717.                       (custom-modify-key-predicate-names
  718.                        (custom-value sym)))))
  719.             (list "\n(define " var "? "
  720.                   "(make-key-predicate " key-val "))"))
  721.               ())))))))
  722.  
  723. ;; API
  724. ;; TODO: implement after uim 0.4.6 depending on scm-nested-eval
  725. (define custom-broadcast-custom
  726.   (lambda (sym)
  727.   #f))
  728.  
  729. ;; API
  730. ;; #f means 'any group'
  731. ;; TODO: support "AND" expression
  732. (define custom-broadcast-customs
  733.   (lambda (group)
  734.     (let ((custom-syms (custom-collect-by-group group)))
  735.       (for-each custom-broadcast-custom custom-syms))))
  736.  
  737. (define custom-register-cb
  738.   (lambda (hook valid? custom-sym ptr gate-func func)
  739.     (and (valid? custom-sym)
  740.      (let ((cb (lambda () (gate-func func ptr custom-sym))))
  741.        (custom-add-hook custom-sym hook cb)))))
  742.  
  743. ;;
  744. ;; predefined subgroups
  745. ;;
  746.  
  747. (define-custom-group 'main
  748.              (N_ "-")
  749.              (N_ "Main settings of this group"))
  750.  
  751. (define-custom-group 'hidden
  752.              (N_ "Hidden settings")
  753.              (N_ "Hidden settings of this group. This group is invisible from uim_custom clients. Exists for internal variable management."))
  754.  
  755.  
  756. (prealloc-heaps-for-heavy-job)
  757. (custom-reload-customs)
  758.